Linux Cubed Series 3: Developer Tools/Linux Cubed Series 3 - Developer Tools.iso/devel/lang/lisp/gcl-1.000/gcl-1/gcl-1.0/cmpnew/cmpspecial.lsp

Lisp/Scheme | 1994-05-07 | 5.6 KB | 154 lines

;;; CMPSPECIAL  Miscellaneous special forms.
;;;
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa

;; This file is part of GNU Common Lisp, herein referred to as GCL
;;
;; GCL is free software; you can redistribute it and/or modify it under
;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;;
;; GCL is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public
;; License for more details.
;;
;; You should have received a copy of the GNU Library General Public License
;; along with GCL; see the file COPYING.  If not, write to the Free Software
;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.


(in-package 'compiler)

(si:putprop 'quote 'c1quote 'c1special)
(si:putprop 'function 'c1function 'c1special)
(si:putprop 'function 'c2function 'c2)
(si:putprop 'the 'c1the 'c1special)
(si:putprop 'eval-when 'c1eval-when 'c1special)
(si:putprop 'declare 'c1declare 'c1special)
(si:putprop 'compiler-let 'c1compiler-let 'c1special)
(si:putprop 'compiler-let 'c2compiler-let 'c2)

(defun c1quote (args)
  (when (endp args) (too-few-args 'quote 1 0))
  (unless (endp (cdr args)) (too-many-args 'quote 1 (length args)))
  (c1constant-value (car args) t)
  )

(defun c1eval-when (args)
  (when (endp args) (too-few-args 'eval-when 1 0))
  (dolist** (situation (car args) (c1nil))
    (case situation
          (eval (return-from c1eval-when (c1progn (cdr args))))
          ((load compile))
          (otherwise
           (cmperr "The situation ~s is illegal." situation))))
  )

(defun c1declare (args)
  (cmperr "The declaration ~s was found in a bad place." (cons 'declare args))
  )

(defun c1the (args &aux info form type)
  (when (or (endp args) (endp (cdr args)))
        (too-few-args 'the 2 (length args)))
  (unless (endp (cddr args))
          (too-many-args 'the 2 (length args)))
  (setq form (c1expr (cadr args)))
  (setq info (copy-info (cadr form)))
  (setq type (type-and (type-filter (car args)) (info-type info)))
  (when (null type)
        (cmpwarn "Type mismatch was found in ~s." (cons 'the args)))
  (setf (info-type info) type)
  (list* (car form) info (cddr form))
  )

(defun c1compiler-let (args &aux (symbols nil) (values nil))
  (when (endp args) (too-few-args 'compiler-let 1 0))
  (dolist** (spec (car args))
    (cond ((consp spec)
           (cmpck (not (and (symbolp (car spec))
                            (or (endp (cdr spec))
                                (endp (cddr spec)))))
                  "The variable binding ~s is illegal." spec)
           (push (car spec) symbols)
           (push (if (endp (cdr spec)) nil (eval (cadr spec))) values))
          ((symbolp spec)
           (push spec symbols)
           (push nil values))
          (t (cmperr "The variable binding ~s is illegal." spec))))
  (setq symbols (reverse symbols))
  (setq values (reverse values))
  (setq args (progv symbols values (c1progn (cdr args))))
  (list 'compiler-let (cadr args) symbols values args)
  )

(defun c2compiler-let (symbols values body)
  (progv symbols values (c2expr body)))

(defun c1function (args &aux fd)
  (when (endp args) (too-few-args 'function 1 0))
  (unless (endp (cdr args)) (too-many-args 'function 1 (length args)))
  (let ((fun (car args)))
       (cond ((symbolp fun)
              (cond ((and (setq fd (c1local-closure fun))
                          (eq (car fd) 'call-local))
                     (list 'function *info* fd))
                    (t (let ((info (make-info
                                    :sp-change
                                    (null (get fun 'no-sp-change)))))
                            (list 'function info (list 'call-global info fun))
                            ))))
             ((and (consp fun) (eq (car fun) 'lambda))
              (cmpck (endp (cdr fun))
                     "The lambda expression ~s is illegal." fun)
              (let ((*vars* (cons 'cb *vars*))
                    (*funs* (cons 'cb *funs*))
                    (*blocks* (cons 'cb *blocks*))
                    (*tags* (cons 'cb *tags*)))
                   (setq fun (c1lambda-expr (cdr fun)))
                   (list 'function (cadr fun) fun)))
             (t (cmperr "The function ~s is illegal." fun))))
  )

(defun c2function (funob)
  (case (car funob)
        (call-global
         (unwind-exit (list 'symbol-function (add-symbol (caddr funob)))))
        (call-local
         (if (cadddr funob)
             (unwind-exit (list 'ccb-vs (fun-ref-ccb (caddr funob))))
             (unwind-exit (list 'vs* (fun-ref (caddr funob))))))
        (t
         ;;; Lambda closure.
         (let ((fun (make-fun :name 'closure :cfun (next-cfun))))
              (push (list 'closure (if (null *clink*) nil (cons 0 0))
                          *ccb-vs* fun funob)
                    *local-funs*)
              (push fun *closures*)
          (cond (*clink*
             (unwind-exit (list 'make-cclosure (fun-cfun fun) *clink*)))
            (t (push-data-incf nil)
               (add-init `(si::setvv ,*next-vv*
                         (si::mc nil ,(add-address  "&LC"
                                    (fun-cfun fun))))
                 t)
               (unwind-exit (list 'vv *next-vv*)))))
             ))
  )

(si:putprop 'symbol-function 'wt-symbol-function 'wt-loc)
(si:putprop 'make-cclosure 'wt-make-cclosure 'wt-loc)

(defun wt-symbol-function (vv)
       (if *safe-compile*
           (wt "symbol_function(VV[" vv "])")
           (wt "(VV[" vv "]->s.s_gfdef)")))

(defun wt-make-cclosure (cfun clink)
       (wt-nl "make_cclosure_new(LC" cfun ",Cnil,")
       (wt-clink clink)
       (wt ",Cdata)"))